home *** CD-ROM | disk | FTP | other *** search
/ L' Effet Pommier 3 / L'Effet Pommier - Volume 03.iso / Programmation / Alpha ƒ / Tcl / SystemCode / misc.tcl < prev    next >
Text File  |  1995-11-11  |  28KB  |  1,045 lines
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {} {
  5.     if {[set chars [expr {[selEnd] - [getPos]}]]} {
  6.         set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  7.         set text [getSelect]
  8.     } else {
  9.         set chars [maxPos]
  10.         set lines [lindex [posToRowCol $chars] 0]
  11.         set text [getText 0 [maxPos]]
  12.     }
  13.     if {[regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " ret]} {
  14.         set words [llength $ret]
  15.     } else {
  16.         set words [llength $text]
  17.     }
  18.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  19. }
  20.  
  21. # proc matchingLines {} {
  22. #     if [catch {prompt "Regular expression:" ""} reg] return
  23. #     if {![string length $reg]} return
  24. #     set reg ^.*$reg.*$
  25. #     set pos [getPos]
  26. #     set matches 0
  27. #     while {![catch {search -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
  28. #         append lines "\r" [format "%4d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch]
  29. #         set pos [lindex $mtch 1]
  30. #         incr matches
  31. #     }
  32. #     new
  33. #     insertText [format "%d matching lines\r-----" $matches] $lines "\r"
  34. # }
  35. set lastMatchingLines ""
  36.  
  37. proc matchingLines {} {
  38.     global lastMatchingLines
  39.     
  40.     if [catch {prompt "Regular expression:" $lastMatchingLines} reg] return
  41.     set lastMatchingLines $reg
  42.     if {![string length $reg]} return
  43.     set reg ^.*$reg.*$
  44.     set pos 0
  45.     set fileName [lindex [winNames -f] 0]
  46.     set matches 0
  47.     while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
  48.         append lines "\r" [format "Line %d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch] "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t░$fileName"
  49.         set pos [lindex $mtch 1]
  50.         incr matches
  51.     }
  52.     new -n {* Matching Lines *}
  53.     insertText [format "%d matching lines (<cr> to go to match)\r-----" $matches] $lines "\r"
  54.     select [nextLineStart [nextLineStart 0]] [nextLineStart [nextLineStart [nextLineStart 0]]]
  55.     
  56.     global winModes
  57.     set name [lindex [winNames] 0]
  58.     changeMode [set winModes($name) Brws]
  59.     setWinInfo dirty 0
  60.     setWinInfo read-only 1
  61.     
  62.     shrinkWindow
  63. }
  64.  
  65. #=============================================================================
  66. # Random functions.
  67. #=============================================================================
  68.  
  69. #================================================================================
  70.  
  71. proc nextFunc {} {
  72.     searchFunc 1
  73. }
  74.  
  75. proc prevFunc {} {
  76.     searchFunc 0
  77. }
  78.  
  79. proc searchFunc {dir} {
  80.     global funcExpr
  81.     set pos [getPos]
  82.     select $pos
  83.     if ($dir==1) {
  84.         incr pos
  85.     } else {
  86.         set pos [expr $pos-1]
  87.     }
  88.     if {![catch {search -s -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
  89.         eval select $res
  90.     }
  91. }
  92.  
  93. #===========================================================================
  94. # Comment routines.
  95. #===========================================================================
  96. proc commentPara {} {
  97. }
  98.  
  99.  
  100.  
  101. #===========================================================================
  102. # Sorting the selection.
  103. # AUTHOR: David C. Black     black@mpd.tandem.com
  104. #===========================================================================
  105. proc sortLines {} {
  106.     set ends [getEndpts]
  107.     set start [lindex $ends 0]
  108.     set end  [lindex $ends 1]
  109.     if {$start == $end} {
  110.         alertnote "You must highlight the section you wish to sort."
  111.         return
  112.     }
  113.     if {[lookAt [expr $end-1]] != "\r"} {
  114.         alertnote "The selection must consist only of complete lines."
  115.         return
  116.     }
  117.     set text [getText $start [expr {$end-1}]]
  118.     set text [join [lsort [split $text "\r"]] "\r"]
  119.     replaceText $start [expr {$end-1}] $text
  120.     select $start $end
  121. }
  122.  
  123.  
  124.  
  125. #===========================================================================
  126. # Dump all current settings into a file.
  127. #===========================================================================
  128. proc insertGlobalSettings {} {
  129.     uplevel #0 {
  130.         foreach var [info globals] {
  131.             if {![catch {set $var}]} {
  132.                 insertText "set " $var " \{" [set $var] "\}\r"
  133.             }
  134.         }
  135.     }
  136. }
  137.  
  138.  
  139. #================================================================================
  140. # Substitute global variables in possibly nested list.
  141. #================================================================================
  142. proc subVars {words} {
  143.     global silly
  144.     global a
  145.     set silly $words
  146.     set out {}
  147.     foreach a $words {
  148.         if {[llength $a] == 1} {
  149.             lappend out [uplevel #0 {eval set x $a}]
  150.         } else {
  151.             lappend out [subVars $a]
  152.         }
  153.     }
  154.     return $out
  155. }
  156.  
  157. #================================================================================
  158. # Block shift left and right.
  159. #================================================================================
  160.  
  161. proc shiftLeft {} {
  162.     global shiftChar
  163.     doShiftLeft "\t"
  164.     
  165. }
  166. proc shiftLeftSpace {} {
  167.     global shiftChar
  168.     doShiftLeft " "
  169. }
  170.  
  171. proc doShiftLeft {shiftChar} {
  172.      set start [lineStart [getPos]]
  173.      set end [nextLineStart [expr [selEnd] - 1]]
  174.     if {$start >= $end} {set end [nextLineStart $start]}
  175.     
  176.     set text [split [getText $start [expr $end - 1]] "\r"]
  177.     
  178.     set textout ""
  179.     
  180.     foreach line $text {
  181.         if {[string index $line 0] == $shiftChar} {
  182.             lappend textout [string range $line 1 end]
  183.         } else {
  184.             lappend textout $line
  185.         }
  186.     }
  187.  
  188.     set text [join $textout "\r"]    
  189.     replaceText $start [expr $end - 1] $text
  190.     select $start [expr 1 + $start + [string length $text]]
  191. }
  192.  
  193.  
  194. proc shiftRight {} {
  195.     global shiftChar
  196.     doShiftRight "\t"
  197.     
  198. }
  199. proc shiftRightSpace {} {
  200.     global shiftChar
  201.     doShiftRight " "
  202. }
  203. proc doShiftRight {shiftChar} {
  204.     set start [lineStart [getPos]]
  205.     set end [nextLineStart [expr [selEnd] - 1]]
  206.     if {$start >= $end} {set end [nextLineStart $start]}
  207.     
  208.     set text [split [getText $start [expr $end - 1]] "\r"]
  209.     
  210.     set textout ""
  211.     
  212.     foreach line $text {
  213.         lappend textout $shiftChar$line
  214.     }
  215.     
  216.     set text [join $textout "\r"]    
  217.     replaceText $start [expr $end - 1] $text
  218.     select $start [expr 1 + $start + [string length $text]]
  219. }
  220.  
  221.  
  222.  
  223. # rglobText [option list] dir pat
  224. # 'dir' should be a properly formed directory, ending w/ a ':'. 'pat' should be 
  225. # a simple pattern w/ no directory specifications (i.e. "*.c").
  226. proc rglobText {optlist dir pat} {
  227.  
  228.     message "$dir"
  229.     set cmd [concat glob -t TEXT $optlist]
  230.     lappend cmd $dir$pat
  231.     if {[catch {eval $cmd} files]} {
  232.         set files ""
  233.     }
  234.     
  235.     if {![catch {glob $dir*} all]} {
  236.         foreach f $all {
  237.             if {[file isdir $f]} {
  238.                 set files [concat $files [rglobText $optlist $f: $pat]]
  239.             }
  240.         }
  241.     }
  242.     return $files
  243. }
  244.  
  245.  
  246. proc switchApp {} {
  247.     set procs ""
  248.     foreach p [processes] {
  249.         lappend procs [lindex $p 0]
  250.     }
  251.     set to [listpick -p "Switch to app:" [lsort $procs]]
  252.     if {[string length $to]} {
  253.         switchTo $to
  254.     }
  255. }
  256.  
  257.  
  258. proc selectAll {} {
  259.     select 0 [maxPos]
  260. }
  261.  
  262.  
  263. proc twiddle {} {
  264.     set pos [getPos]
  265.     if {!$pos || ($pos == [maxPos])} return;
  266.     if {[string length [set text [getSelect]]]} {
  267.         if {[string length $text] == 1} {
  268.             return
  269.         } else {
  270.             set sel [expr [selEnd] - 1]
  271.             set one [lookAt $sel]
  272.             set two [lookAt $pos]
  273.             replaceText $pos [expr $sel + 1] "$one[getText [expr $pos+1] $sel]$two"
  274.             select $pos [expr $sel+1]
  275.             return
  276.         }
  277.     }
  278.     set one [lookAt $pos]
  279.     set two [lookAt [expr $pos-1]]
  280.     replaceText [expr $pos-1] [expr $pos + 1] "$one$two"
  281.     select  [expr $pos-1] [expr $pos + 1]
  282. }
  283.  
  284. proc twiddleWords {} {
  285.     global wordBreakPreface wordBreak
  286.  
  287.     if {[getPos] != [selEnd]} {
  288.         set start1 [getPos]; set end2 [selEnd]
  289.         select $start1
  290.         forwardWord; set end1 [getPos]
  291.         goto $end2
  292.         backwardWord; set start2 [getPos]
  293.     } else {
  294.         select [set pos [getPos]]
  295.         backwardWord; set start1 [getPos]
  296.         forwardWord; set end1 [getPos]
  297.         goto $pos
  298.         forwardWord; set end2 [getPos]
  299.         backwardWord; set start2 [getPos]
  300.     }        
  301.  
  302.     if {$start1 != $start2} {
  303.         set mid [getText $end1 $start2]
  304.         replaceText $start1 $end2 "[getText $start2 $end2]$mid[getText $start1 $end1]"
  305.         select $start1 $end2
  306.     }
  307. }
  308.  
  309. #================================================================================
  310. # Print a window using John Cho's Enscriptor (A text file printing app that
  311. # works like Adobe Enscript.)
  312. #
  313.  
  314. proc setupPrintMenu {} {
  315.     global pathComments defaultPrinter modifiedVars
  316.     if {![info exists defaultPrinter]} {
  317.         set defaultPrinter "Alpha"
  318.         lappend modifiedVars defaultPrinter
  319.     }
  320.     set m [list {/P<SPrint╔} {/P<S<I<OPrint All╔} {(-} Alpha $pathComments(kodexPath) $pathComments(enscriptorPath) $pathComments(droppsPath)]
  321.     menu -m -n print -p printProc $m
  322.     
  323.     foreach item $m {
  324.         if {$item == $defaultPrinter} {
  325.             markMenuItem -m print $item on
  326.         } else {
  327.             markMenuItem -m print $item off
  328.         }
  329.     }
  330. }
  331.  
  332. proc printProc {menu item} {
  333.     global modifiedVars defaultPrinter pathComments
  334.     switch -glob $item {
  335.         "Print All"        {    if {$defaultPrinter == "Alpha"} {
  336.                                 printAll
  337.                             } else {
  338.                                 foreach f [winNames -f] {
  339.                                     printFile $f
  340.                                 }
  341.                             }
  342.                         }
  343.         "Print"            {printFile [lindex [winNames -f] 0]}
  344.         "Alpha"            {set defaultPrinter "Alpha"; lappend modifiedVars defaultPrinter; setupPrintMenu}
  345.         "Kodex*"        {set defaultPrinter $pathComments(kodexPath); lappend modifiedVars defaultPrinter; setupPrintMenu}
  346.         "Enscr*"        {set defaultPrinter $pathComments(enscriptorPath); lappend modifiedVars defaultPrinter; setupPrintMenu}
  347.         "Drop*"            {set defaultPrinter $pathComments(droppsPath); lappend modifiedVars defaultPrinter; setupPrintMenu}
  348.     }
  349. }
  350.  
  351.  
  352. proc printFile {fname} {
  353.     global defaultPrinter
  354.     
  355.     switch -glob $defaultPrinter {
  356.         "Alpha"            {print}
  357.         "Kodex*"        {openAndSendFile $fname kodexPath Kodex KoDX}
  358.         "Enscr*"        {openAndSendFile $fname enscriptorPath Enscriptor Ens3}
  359.         "Drop*"            {openAndSendFile $fname droppsPath {DropÑPS} {DÑPS}}
  360.     }
  361. }
  362.  
  363.  
  364. proc openAndSendFile {fname path name sig} {
  365.     global $path
  366.  
  367.     catch {checkRunning $name $sig $path} name
  368.  
  369.     if {[winDirty]} {
  370.         if {[askyesno "Save '$fname'?"] == "yes"} {
  371.             save
  372.         }
  373.     }
  374.     message "Sending to '$name'..."
  375.     if {[catch {sendOpenEvent noReply $name $fname}] } {
  376.         beep 
  377.     } else {
  378.         switchTo $name
  379.     }
  380.     message ""
  381. }
  382.  
  383. proc commentBox {} {
  384.  
  385. # Preliminaries
  386.     if [commentGetRegion Box] { return }
  387.     
  388.     set commentList [commentCharacters Box]
  389.     if { [llength $commentList] == 0 } { return }
  390.     
  391.     set begComment [lindex $commentList 0]
  392.     set begComLen [lindex $commentList 1]
  393.     set endComment [lindex $commentList 2]
  394.     set endComLen [lindex $commentList 3]
  395.     set fillChar [lindex $commentList 4]
  396.     set spaceOffset [lindex $commentList 5]
  397.  
  398.     set aSpace " "
  399.  
  400. # First make sure we grab a full block of lines and adjust highlight
  401.  
  402.     set start [getPos]
  403.     set start [lineStart $start]
  404.     set end [selEnd]
  405.     set end [nextLineStart [expr $end-1]]
  406.     select $start $end
  407.  
  408. # Now get rid of any tabs
  409.     
  410.     if { $end < [maxPos] } then {
  411.         createTMark stopComment [expr $end+1]
  412.         tabsToSpaces
  413.         gotoTMark stopComment
  414.         set end [expr [getPos]-1]
  415.         removeTMark stopComment
  416.     } else {
  417.         tabsToSpaces
  418.         set end [maxPos]
  419.     }
  420.     select $start $end
  421.     set text [getText $start $end]
  422.     
  423. # Next turn it into a list of lines--possibly drop an empty 'last line'
  424.  
  425. # VMD May'95: changed this code segment because it
  426. # previously had problems with empty lines in the
  427. # middle of the text to be commented
  428.  
  429.     set lineList [split $text "\r"]
  430.     set ll [llength $lineList]
  431.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  432.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  433.     }
  434.     set numLines [llength $lineList]
  435.  
  436. # end changes.
  437.     
  438. # Find the longest line length and determine the new line length
  439.  
  440.     set maxLength 0
  441.     foreach thisLine $lineList {
  442.         set thisLength [string length $thisLine]
  443.         if { $thisLength > $maxLength } then { 
  444.             set maxLength $thisLength 
  445.         }
  446.     }
  447.     set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]
  448.     
  449. # Now create the top & bottom bars and a blank line
  450.  
  451.     set topBar $begComment
  452.     for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
  453.         set topBar $topBar$fillChar
  454.     }
  455.     set botBar ""
  456.     for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
  457.         set botBar $botBar$fillChar
  458.     }
  459.     set botBar $botBar$endComment
  460.     set blankLine $fillChar
  461.     for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
  462.         set blankLine $blankLine$aSpace
  463.     }
  464.     set blankLine $blankLine$fillChar
  465.     
  466. # For each line add stuff on left and spaces and stuff on right for box sides
  467. # and concatenate everything into 'text'.  Start with topBar; end with botBar
  468.  
  469.     set text $topBar\r$blankLine\r
  470.     
  471.     set frontStuff $fillChar
  472.     set backStuff $fillChar
  473.     for { set i 0 } { $i < $spaceOffset } { incr i } {
  474.         set frontStuff $frontStuff$aSpace  
  475.         set backStuff $aSpace$backStuff
  476.     }
  477.     set backStuffLen [string length $backStuff]
  478.     
  479.     for { set i 0 } { $i < $numLines } { incr i } {
  480.         set thisLine [lindex $lineList $i ]
  481.         set thisLine $frontStuff$thisLine
  482.         set thisLength [string length $thisLine]
  483.         set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
  484.         for { set j 0 } { $j < $howMuchPad } { incr j } {
  485.             set thisLine $thisLine$aSpace 
  486.         }
  487.         set thisLine $thisLine$backStuff
  488.         set text $text$thisLine\r
  489.     }
  490.     
  491.     set text $text$blankLine\r$botBar\r
  492.     
  493. # Now replace the old stuff, turn spaces to tabs, and highlight
  494.  
  495.     replaceText    $start $end    $text
  496.     set    end    [expr {$start+[string length $text]}]
  497.     cleverSpacesToTabs $start $end
  498. }
  499.  
  500. proc uncommentBox {} {
  501.  
  502. # Preliminaries
  503.     if [commentGetRegion Box 1] { return }
  504.     
  505.     set commentList [commentCharacters Box]
  506.     if { [llength $commentList] == 0 } { return }
  507.     
  508.     set    begComment [lindex $commentList    0]
  509.     set    begComLen [lindex $commentList 1]
  510.     set    endComment [lindex $commentList    2]
  511.     set    endComLen [lindex $commentList 3]
  512.     set    fillChar [lindex $commentList 4]
  513.     set    spaceOffset    [lindex    $commentList 5]
  514.  
  515.     set aSpace " "
  516.     set aTab \t
  517.  
  518. # First make sure we grab a full block of lines
  519.  
  520.     set start [getPos]
  521.     set start [lineStart $start]
  522.     set end [selEnd]
  523.     set end [nextLineStart [expr $end-1]]
  524.     set text [getText $start $end]
  525.  
  526. # Make sure we're at the start and end of the box
  527.  
  528.     set startOK [string first $begComment $text]
  529.     set endOK [string last $endComment $text]
  530.     set textLength [string length $text]
  531.     if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } then {
  532.         alertnote "You must highlight the entire comment box, including the borders."
  533.         return
  534.     }
  535.     
  536. # Now get rid of any tabs
  537.     
  538.     if { $end < [maxPos] } then {
  539.         createTMark stopComment [expr $end+1]
  540.         tabsToSpaces
  541.         gotoTMark stopComment
  542.         set end [expr [getPos]-1]
  543.         removeTMark stopComment
  544.     } else {
  545.         tabsToSpaces
  546.         set end [maxPos]
  547.     }
  548.     select $start $end
  549.     set text [getText $start $end]
  550.     
  551. # Next turn it into a list of lines--possibly drop an empty 'last line'
  552.  
  553. # VMD May'95: changed this code segment because it
  554. # previously had problems with empty lines in the
  555. # middle of the text to be commented
  556.  
  557.     set lineList [split $text "\r"]
  558.     set ll [llength $lineList]
  559.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  560.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  561.     }
  562.     set numLines [llength $lineList]
  563.  
  564. # end changes.
  565.     
  566. # Delete the first and last lines, recompute number of lines
  567.  
  568.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  569.     set lineList [lreplace $lineList 0 0 ]
  570.     set numLines [llength $lineList]
  571.     
  572. # Eliminate 2nd and 2nd-to-last lines if they are empty
  573.  
  574.     set eliminate $fillChar$aSpace$aTab
  575.     set thisLine [lindex $lineList [expr $numLines-1]]
  576.     set thisLine [string trim $thisLine $eliminate]
  577.     if { [string length $thisLine] == 0 } then {
  578.         set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  579.     }
  580.     set thisLine [lindex $lineList 0]
  581.     set thisLine [string trim $thisLine $eliminate]
  582.     if { [string length $thisLine] == 0 } then {
  583.         set lineList [lreplace $lineList 0 0 ]
  584.     }
  585.     set numLines [llength $lineList]    
  586.     
  587. # For each line trim stuff on left and spaces and stuff on right and splice
  588.  
  589.     set dropFromLeft [expr $spaceOffset+1]
  590.     set text ""
  591.     for { set i 0 } { $i < $numLines } { incr i } {
  592.         set thisLine [lindex $lineList $i]
  593.         set thisLine [string trimright $thisLine $eliminate]
  594.         set thisLine [string range $thisLine $dropFromLeft end]
  595.         set text $text$thisLine\r
  596.     }
  597.         
  598. # Now replace the old stuff, convert spaces back to tabs
  599.  
  600.     replaceText    $start $end    $text
  601.     set end [expr {$start+[string    length $text]}]
  602.     cleverSpacesToTabs $start $end
  603. }
  604.  
  605. proc commentCharacters { purpose } {
  606.     global mode
  607.     
  608.     switch $purpose {
  609.         "Paragraph" {        
  610.             switch $mode {
  611.                 "TeX" {return [list "%% " " %%" " % "] }
  612.                 "Text" {return [list "!! " " !!" " ! "] }
  613.                 "Fort" {return [list "CC " " CC" " C "] }
  614.                 "Tcl" {return [list "## " " ##" " # "] }
  615.                 "C" {return [list "/* " " */" " * "] }
  616.                 "C++" {return [list "/* " " */" " * "] }
  617.                 default {
  618.                     alertnote "I don't know what comments should look like in this mode.  Sorry."
  619.                     return
  620.                 }
  621.             }
  622.         }
  623.         "Box" {
  624.         switch $mode {
  625.                 "TeX" {return [list "%" 1 "%" 1 "%" 3] }
  626.                 "Text" {return [list "!" 1 "!" 1 "!" 3] }
  627.                 "Fort" {return [list "C" 1 "C" 1 "C" 3] }
  628.                 "Tcl" {return [list "#" 1 "#" 1 "#" 3] }
  629.                 "C" {return [list "/*" 2 "*/" 2 "*" 3] }
  630.                 "C++" {return [list "/*" 2 "*/" 2 "*" 3] }
  631.                 default {
  632.                     alertnote "I don't know what comments should look like in this mode.  Sorry."
  633.                     return
  634.                 }
  635.             }    
  636.         }
  637.     }    
  638.  
  639. }
  640.  
  641. ## 
  642.  # Default is to look for a    paragraph to comment out.
  643.  # If sent '1',    then we    look for a commented region    to 
  644.  # uncomment.
  645.  ##
  646. proc commentGetRegion { purpose {uncomment 0 } } {
  647.     if {[getPos] != [selEnd]} {
  648.         watchCursor
  649.         return 0    
  650.     }
  651.  
  652.     # there's no selection, so we try and generate one
  653.     
  654.     set pos [getPos]
  655.     if $uncomment {
  656.         # uncommenting
  657.         set commentList [commentCharacters $purpose]
  658.         if { [llength $commentList] == 0 } { return 1}
  659.         switch $purpose {
  660.             "Box" {
  661.                 set begComment [lindex $commentList 0]
  662.                 set begComLen [lindex $commentList 1]
  663.                 set endComment [lindex $commentList 2]
  664.                 set endComLen [lindex $commentList 3]
  665.                 set fillChar [lindex $commentList 4]
  666.                 set spaceOffset [lindex $commentList 5]
  667.                 
  668.                 # get length of current line
  669.                 set line [getText [lineStart $pos] [nextLineStart $pos] ]
  670.                 set c [string trimleft $line]
  671.                 set slen [expr [string length $line] - [string length $c] ]
  672.                 set start [string range $line 0 [expr $slen -1 ] ]
  673.                 
  674.                 set pos [getPos]
  675.                 
  676.                 if { $start == "" } {
  677.                     set p $pos
  678.                     while { [string first $fillChar $line] == 0 && \
  679.                         [expr [string last $fillChar $line] + [string length $fillChar]] \
  680.                         >= [string length [string trimright $line]] } {
  681.                         set p [nextLineStart $p]
  682.                         set line [getText [lineStart $p] [nextLineStart $p]]
  683.                     }
  684.                     set end [lineStart $p]
  685.                     
  686.                     set p $pos
  687.                     set line "${fillChar}"
  688.                     while { [string first $fillChar $line] == 0 && \
  689.                         [expr [string last $fillChar $line] + [string length $fillChar]] \
  690.                         >= [string length [string trimright $line]] } {
  691.                         set p [prevLineStart $p]
  692.                         set line [getText [prevLineStart $p] [lineStart $p] ]
  693.                     }
  694.                     set begin [prevLineStart $p]
  695.                     
  696.                 } else {
  697.                     set line "$start"
  698.                     set p $pos
  699.                     while { [string range $line 0 [expr $slen -1] ] == "$start" } {
  700.                         set p [nextLineStart $p]
  701.                         set line [getText [lineStart $p] [nextLineStart $p]]
  702.                     }
  703.                     set end [prevLineStart $p]
  704.                     
  705.                     set p $pos
  706.                     set line "$start"
  707.                     while { [string range $line 0 [expr $slen -1] ] == "$start" } {
  708.                         set p [prevLineStart $p]
  709.                         set line [getText [prevLineStart $p] [lineStart $p] ]
  710.                     }
  711.                     set begin [lineStart $p]
  712.                 }
  713.  
  714.                 set beginline [getText $begin [nextLineStart  $begin]]
  715.                 if { [string first "$begComment" "$beginline" ] != $slen } {
  716.                     message "First line failed"
  717.                     return 1
  718.                 }
  719.                 
  720.                 set endline [getText $end [nextLineStart $end]]
  721.                 set epos [string last "$endComment" "$endline"]
  722.                 incr epos [string length $endComment]
  723.                 set s [string range $endline $epos end ]
  724.                 set s [string trimright $s]
  725.                 
  726.                 if { $s != "" } {
  727.                     message "Last line failed"
  728.                     return 1
  729.                 }
  730.                 
  731.                 set end [nextLineStart $end]
  732.                 select $begin $end
  733.                 #alertnote "Sorry auto-box selection not yet implemented"
  734.             }
  735.             "Paragraph" {
  736.                 set begComment [lindex $commentList 0]
  737.                 set endComment [lindex $commentList 1]
  738.                 set fillChar [lindex $commentList 2]
  739.                 
  740.                 ## 
  741.                  # basic idea is search    back and forwards for lines
  742.                  # that    don't begin    the    same way and then see if they
  743.                  # match the idea of the beginning and end of a    block
  744.                  ##
  745.                 
  746.                 set line [getText [lineStart $pos] [nextLineStart $pos] ]
  747.                 set chk [string range $line 0 [string first $fillChar $line]]
  748.                 if { [string trimleft $chk] != "" } {
  749.                     message "Not in a comment block"
  750.                     return 1
  751.                 }
  752.                 regsub -all {    } $line " " line
  753.                 set p [string first "$fillChar" "$line"]
  754.                 set start [string range "$line" 0 [expr $p + [string length $fillChar] -1 ]]
  755.                 set ll [commentGetFillLines $start]
  756.                 set begin [lindex $ll 0]
  757.                 set end [lindex $ll 1]
  758.                 
  759.                 set beginline [getText $begin [nextLineStart  $begin]]
  760.                 if { [string first "$begComment" "$beginline" ] != $p } {
  761.                     message "First line failed"
  762.                     return 1
  763.                 }
  764.                 
  765.                 set endline [getText $end [nextLineStart $end]]
  766.                 set epos [string last "$endComment" "$endline"]
  767.                 incr epos [string length $endComment]
  768.                 set s [string range $endline $epos end ]
  769.                 set s [string trimright $s]
  770.                 
  771.                 if { $s != "" } {
  772.                     message "Last line failed"
  773.                     return 1
  774.                 }
  775.                 #goto $end
  776.                 set end [nextLineStart $end]
  777.                 select $begin $end
  778.             }
  779.         }
  780.     } else {
  781.         # commenting out
  782.         set searchString {^[ \t]*$}
  783.         set searchResult1 [search -s -f 0 -r 1 -n $searchString $pos]
  784.         set searchResult2 [search -s -f 1 -r 1 -n $searchString $pos]
  785.         if {[llength $searchResult1]} then {
  786.             set posStart [expr [lindex $searchResult1 1] +1]
  787.         } else {
  788.             set posStart 0
  789.         }
  790.         if {[llength $searchResult2]} then {
  791.             set posEnd [lindex $searchResult2 0]
  792.         } else {
  793.             set posEnd [expr [maxPos] +1]
  794.             goto [maxPos]
  795.             insertText "\n"
  796.         }
  797.         select $posStart $posEnd
  798.     }
  799.     
  800.      set str "Do you wish to "
  801.      if $uncomment { append str "uncomment" } else { append str "comment out" }
  802.      append str " this region?"
  803.     if { [askyesno $str] == "yes" } {
  804.         return 0
  805.     } else {
  806.         return 1
  807.     }
  808. }
  809.  
  810.  
  811. proc prevLineStart { pos } {
  812.     return [lineStart [expr [lineStart $pos]-1]]
  813. }
  814.  
  815. proc commentSameStart { line start } {
  816.     regsub -all {    } "$line" " " line
  817.     if { [string first "$start" "$line"] == 0 } {
  818.         return 1
  819.     } else {
  820.         return 0
  821.     }
  822. }
  823.  
  824. proc commentGetFillLines { start } {
  825.     set pos [getPos]
  826.     regsub -all {[\t]} $start " " start
  827.     set line "$start"
  828.     
  829.     set p $pos
  830.     while { [commentSameStart "$line" "$start"] } {
  831.         set p [nextLineStart $p]
  832.         set line [getText [lineStart $p] [nextLineStart $p]]
  833.     }
  834.     set end [lineStart $p]
  835.     
  836.     set p $pos
  837.     set line "$start"
  838.     while { [commentSameStart "$line" "$start"] } {
  839.         set p [prevLineStart $p]
  840.         set line [getText [prevLineStart $p] [lineStart $p] ]
  841.     }
  842.     set begin [prevLineStart $p]
  843.     return [list $begin $end]
  844. }
  845.  
  846. ## 
  847.  # Author: Vince Darley    <mailto:vince@das.harvard.edu> 
  848.  ##
  849.  
  850. proc commentParagraph {} {
  851.  
  852. # Preliminaries
  853.     if [commentGetRegion Paragraph] { return }
  854.     
  855.     set commentList [commentCharacters Paragraph]
  856.     if { [llength $commentList] == 0 } { return }
  857.     
  858.     set begComment [lindex $commentList 0]
  859.     set endComment [lindex $commentList 1]
  860.     set fillChar [lindex $commentList 2]
  861.     
  862.  
  863. # First make sure we grab a full block of lines and adjust highlight
  864.  
  865.     set start [getPos]
  866.     set start [lineStart $start]
  867.     set end [selEnd]
  868.     set end [nextLineStart [expr $end-1]]
  869.     select $start $end
  870.  
  871. # Now get rid of any tabs
  872.     
  873.     if { $end < [maxPos] } then {
  874.         createTMark stopComment [expr $end+1]
  875.         tabsToSpaces
  876.         gotoTMark stopComment
  877.         set end [expr [getPos]-1]
  878.         removeTMark stopComment
  879.     } else {
  880.         tabsToSpaces
  881.         set end [maxPos]
  882.     }
  883.     select $start $end
  884.     set text [getText $start $end]
  885.     
  886. # Next turn it into a list of lines--possibly drop an empty 'last line'
  887.  
  888.     set lineList [split $text "\r"]
  889.     set ll [llength $lineList]
  890.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  891.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  892.     }
  893.     set numLines [llength $lineList]
  894.  
  895. # Find left margin for these lines
  896.     set lmargin 100
  897.     for { set i 0 } { $i < $numLines } { incr i } {
  898.         set l [lindex $lineList $i]
  899.         set lm [expr [string length $l] - [string length [string trimleft $l]]]
  900.         if { $lm < $lmargin } { set lmargin $lm }
  901.     }
  902.     set ltext ""
  903.     for { set i 0 } { $i < $lmargin } { incr i } {
  904.         append ltext " "
  905.     }
  906.     
  907. # For each line add stuff on left and concatenate everything into 'text'. 
  908.  
  909.     set text ${ltext}${begComment}\r
  910.     
  911.     for { set i 0 } { $i < $numLines } { incr i } {
  912.         append text ${ltext}${fillChar}[string range [lindex $lineList $i ] $lmargin end]\r
  913.     }
  914.     append text ${ltext}${endComment}\r
  915.     
  916. # Now replace the old stuff, turn spaces to tabs, and highlight
  917.  
  918.     replaceText    $start $end    $text
  919.     set    end    [expr {$start+[string length $text]}]
  920.     cleverSpacesToTabs $start $end
  921. }
  922.  
  923. ## 
  924.  # Author: Vince Darley    <mailto:vince@das.harvard.edu> 
  925.  ##
  926.  
  927. proc uncommentParagraph {} {
  928.  
  929. # Preliminaries
  930.     if [commentGetRegion Paragraph 1] { return }
  931.     
  932.     set commentList [commentCharacters Paragraph]
  933.     if { [llength $commentList] == 0 } { return }
  934.     
  935.     set begComment [lindex $commentList 0]
  936.     set endComment [lindex $commentList 1]
  937.     set fillChar [lindex $commentList 2]
  938.  
  939.     set aSpace " "
  940.     set aTab \t
  941.  
  942. # First make sure we grab a full block of lines and adjust highlight
  943.  
  944.     set start [getPos]
  945.     set start [lineStart $start]
  946.     set end [selEnd]
  947.     set end [nextLineStart [expr $end-1]]
  948.     select $start $end
  949.     set text [getText $start $end]
  950.  
  951. # Find left margin for these lines
  952.     set l [string range $text 0 [string first "\r" $text] ]
  953.     set lmargin [expr [string length $l] - [string length [string trimleft $l]]]
  954.  
  955. # Make sure we're at the start and end of the paragraph
  956.  
  957.     set startOK [string first $begComment $text]
  958.     set endOK [string last $endComment $text]
  959.     set textLength [string length $text]
  960.     if { $startOK != $lmargin || ($endOK != [expr {$textLength-[string length $endComment]-1}] || $endOK == -1) } then {
  961.         alertnote "You must highlight the entire comment paragraph, including the tail ends."
  962.         return
  963.     }
  964.  
  965. # Now get rid of any tabs
  966.     
  967.     if { $end < [maxPos] } then {
  968.         createTMark stopComment [expr $end+1]
  969.         tabsToSpaces
  970.         gotoTMark stopComment
  971.         set end [expr [getPos]-1]
  972.         removeTMark stopComment
  973.     } else {
  974.         tabsToSpaces
  975.         set end [maxPos]
  976.     }
  977.     select $start $end
  978.     set text [getText $start $end]
  979.     
  980. # Next turn it into a list of lines--possibly drop an empty 'last line'
  981.  
  982.     set lineList [split $text "\r"]
  983.     set ll [llength $lineList]
  984.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  985.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  986.     }
  987.     set numLines [llength $lineList]
  988.     
  989. # Delete the first and last lines, recompute number of lines
  990.  
  991.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  992.     set lineList [lreplace $lineList 0 0 ]
  993.     set numLines [llength $lineList]
  994.  
  995. # get the left margin
  996.     set lmargin [string first $fillChar [lindex $lineList 0]]
  997.     set ltext ""
  998.     for { set i 0 } { $i < $lmargin } { incr i } {
  999.         append ltext " "
  1000.     }
  1001.  
  1002. # For each line trim stuff on left and spaces and stuff on right and splice
  1003.     set eliminate $fillChar$aSpace$aTab
  1004.     set dropFromLeft [expr [string length $fillChar] + $lmargin]
  1005.     set text ""
  1006.     for { set i 0 } { $i < $numLines } { incr i } {
  1007.         set thisLine [lindex $lineList $i]
  1008.         set thisLine [string trimright $thisLine $eliminate]
  1009.         set thisLine ${ltext}[string range $thisLine $dropFromLeft end]
  1010.         set text $text$thisLine\r
  1011.     }
  1012.     
  1013. # Now replace the old stuff, turn spaces to tabs, and highlight
  1014.  
  1015.  
  1016.     replaceText    $start $end    $text
  1017.     set    end    [expr {$start+[string length $text]}]
  1018.     cleverSpacesToTabs $start $end
  1019. }
  1020.  
  1021.  
  1022. proc cleverTabsToSpaces { start end } {
  1023.     cleverSpacesTabs tabsToSpaces $start $end
  1024. }
  1025.  
  1026. proc cleverSpacesToTabs { start end } {
  1027.     cleverSpacesTabs spacesToTabs $start $end
  1028. }
  1029.  
  1030. proc cleverSpacesTabs { fn start end } {
  1031.    set e [expr $end+1]
  1032.    if { $e > [maxPos] } { 
  1033.        goto $end
  1034.        openLine
  1035.    }
  1036.    createTMark stopComment $e
  1037.    select $start $end
  1038.    $fn
  1039.    gotoTMark stopComment
  1040.    set end [expr [getPos]-1]
  1041.    removeTMark stopComment
  1042.    return [list $start $end]
  1043. }
  1044.  
  1045.